home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN2.LZH / POLISH.FOR < prev    next >
Encoding:
Text File  |  1988-02-08  |  4.5 KB  |  165 lines
  1.       SUBROUTINE POLISH ( TOKE, NTOKE, FACTS, ERR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **           POLISH          **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          POLISH NOTATION CONVERSION
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CALIF   94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          TO REPLACE THE UNITS ARRAY (WHICH IS IN ALGEBRAIC
  23. C*          NOTATION) WITH THE EQUIVALENT REVERSE POLISH STRING.
  24. C*
  25. C*     METHODOLOGY :
  26. C*          USE THE STACK COMPILATION TECHNIQUE, REFERENCE:
  27. C*          KATZAN, "ADVANCED PROGRAMMING", VAN NOSTRAND REINHOLD CO,
  28. C*          NEW YORK, 1970.
  29. C*
  30. C*     INPUT ARGUMENTS :
  31. C*          TOKE  - THE LIST OF TOKENS IN ALGEBRAIC FORM
  32. C*          NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'
  33. C*
  34. C*     OUTPUT ARGUMENTS :
  35. C*          TOKE  - THE NEW LIST IN REVERSE POLISH FORM
  36. C*          NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'
  37. C*          ERR   - SET TRUE FOR UNMATCHED PARENTHESES.
  38. C*
  39. C*     INTERNAL WORK AREAS :
  40. C*          ISTACK, STACK - TEMPORARY OPERATOR STACKS
  41. C*
  42. C*     COMMON BLOCKS :
  43. C*          NONE
  44. C*
  45. C*     FILE REFERENCES :
  46. C*          NONE
  47. C*
  48. C*     SUBPROGRAM REFERENCES :
  49. C*          NONE
  50. C*
  51. C*     ERROR PROCESSING :
  52. C*          CHECK EACH RIGHT PAREN FOR A MATCHING LEFT PAREN
  53. C*
  54. C*     TRANSPORTABILITY LIMITATIONS :
  55. C*          SUBPROGRAM NAME IS LONGER THAN 6 CHARACTERS
  56. C*
  57. C*     ASSUMPTIONS AND RESTRICTIONS :
  58. C*          NONE
  59. C*
  60. C*     LANGUAGE AND COMPILER :
  61. C*          ANSI FORTRAN 77
  62. C*
  63. C*     VERSION AND DATE :
  64. C*          VERSION I.0      7-FEB-85
  65. C*
  66. C*     CHANGE HISTORY :
  67. C*           7-FEB-85    INITIAL VERSION
  68. C*
  69. C***********************************************************************
  70. C*
  71.       CHARACTER *6 TOKE(1), STACK(20)
  72.       DOUBLE PRECISION FACTS(1), FSTACK(20)
  73.       DIMENSION ISTACK(20)
  74.       LOGICAL ERR
  75. C
  76.       ISP   = 1
  77.       IPOLE = 0
  78.       ISTACK ( ISP ) = -1
  79.       STACK ( ISP )  = ' '
  80.       FSTACK ( ISP ) = 0.D0
  81. C
  82. C --- ALL TOKENS
  83. C
  84.       DO 100 I = 1, NTOKE
  85. C
  86. C ----- '(' STACK IT ONLY
  87. C
  88.          IF (TOKE(I) .EQ. '(') THEN
  89.             ISP = ISP + 1
  90.             STACK(ISP)  = TOKE(I)
  91.             ISTACK(ISP) = 0
  92.             FSTACK(ISP) = FACTS(I)
  93. C
  94. C ----- ')' UNSTACK UNTIL MATCHING '(' IS FOUND
  95. C
  96.          ELSE IF (TOKE(I) .EQ. ')') THEN
  97. 20          IF (ISTACK(ISP) .NE. 0) THEN
  98.                IPOLE = IPOLE + 1
  99.                TOKE(IPOLE)  = STACK(ISP)
  100.                FACTS(IPOLE) = FSTACK(ISP)
  101.                ISP = ISP - 1
  102.                IF (IPOLE .LE. 0) THEN
  103.                   ERR = .TRUE.
  104.                   RETURN
  105.                ENDIF
  106.                GO TO 20
  107.             ENDIF
  108.             ISP = ISP - 1
  109. C
  110. C ----- '*' OR '/' ... UNSTACK ANY '^', '*', OR '/' ON THE STACK
  111. C
  112.          ELSE IF ((TOKE(I) .EQ. '*') .OR.
  113.      $            (TOKE(I) .EQ. '/')) THEN
  114. 30          IF (ISTACK(ISP) .GE. 8) THEN
  115.                IPOLE = IPOLE + 1
  116.                TOKE(IPOLE)  = STACK(ISP)
  117.                FACTS(IPOLE) = FSTACK(ISP)
  118.                ISP = ISP - 1
  119.                GO TO 30
  120.             ENDIF
  121.             ISP = ISP + 1
  122.             STACK(ISP)  = TOKE(I)
  123.             FSTACK(ISP) = FACTS(I)
  124.             ISTACK(ISP) = 8
  125. C
  126. C ----- '^' ... UNSTACK ANY '^' ON THE STACK
  127. C
  128.          ELSE IF (TOKE(I) .EQ. '^') THEN
  129. 40          IF (ISTACK(ISP) .GE. 9) THEN
  130.                IPOLE = IPOLE + 1
  131.                TOKE(IPOLE)  = STACK(ISP)
  132.                FACTS(IPOLE) = FSTACK(ISP)
  133.                ISP = ISP - 1
  134.                GO TO 40
  135.             ENDIF
  136.             ISP = ISP + 1
  137.             STACK(ISP)  = TOKE(I)
  138.             FSTACK(ISP) = FACTS(I)
  139.             ISTACK(ISP) = 9
  140. C
  141. C ----- UNITS AND EXPONENTS GET MOVED DIRECTLY TO OUTPUT
  142. C
  143.          ELSE
  144.             IPOLE = IPOLE + 1
  145.             TOKE(IPOLE)  = TOKE(I)
  146.             FACTS(IPOLE) = FACTS(I)
  147.          ENDIF
  148. 100      CONTINUE
  149.       NTOKE = IPOLE
  150. C
  151. C --- THERE MAY STILL BE OPERATORS ON THE STACK... UNSTACK THEM
  152. C
  153. 300   IF (ISP .GT. 1) THEN
  154.          NTOKE = NTOKE + 1
  155.          TOKE(NTOKE) = STACK(ISP)
  156.          FACTS(NTOKE)= FSTACK(ISP)
  157.          ISP = ISP - 1
  158.          GO TO 300
  159.       ENDIF
  160.       RETURN
  161.       END
  162. C
  163. C---END POLISH
  164. C
  165.